home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / prec.scm < prev    next >
Text File  |  1999-04-19  |  16KB  |  449 lines
  1. ; "prec.scm", dynamically extensible parser/tokenizer    -*-scheme-*-
  2. ; Copyright 1989, 1990, 1991, 1992, 1993, 1995, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ; This file implements:
  21. ; * a Pratt style parser.
  22. ; * a tokenizer which congeals tokens according to assigned classes of
  23. ;   constituent characters.
  24. ;
  25. ; This module is a significant improvement because grammar can be
  26. ; changed dynamically from rulesets which don't need compilation.
  27. ; Theoretically, all possibilities of bad input are handled and return
  28. ; as much structure as was parsed when the error occured; The symbol
  29. ; `?' is substituted for missing input.
  30.  
  31. ; References for the parser are:
  32.  
  33. ; Pratt, V. R.
  34. ; Top Down Operator Precendence.
  35. ; SIGACT/SIGPLAN
  36. ; Symposium on Principles of Programming Languages,
  37. ; Boston, 1973, 41-51
  38.  
  39. ; WORKING PAPER 121
  40. ; CGOL - an Alternative External Representation For LISP users
  41. ; Vaughan R. Pratt
  42. ; MIT Artificial Intelligence Lab.
  43. ; March 1976
  44.  
  45. ; Mathlab Group,
  46. ; MACSYMA Reference Manual, Version Ten,
  47. ; Laboratory for Computer Science, MIT, 1983
  48.  
  49. (require 'fluid-let)
  50. (require 'string-search)
  51. (require 'string-port)
  52. (require 'delay)
  53.  
  54. (define *syn-defs* #f)
  55. (define *syn-rules* #f)            ;Dynamically bound
  56. (define *prec:port* #f)            ;Dynamically bound
  57.  
  58. ;; keeps track of input column so we can generate useful error displays.
  59. (define tok:column 0)
  60. (define (tok:peek-char) (peek-char *prec:port*))
  61. (define (tok:read-char)
  62.   (let ((c (read-char *prec:port*)))
  63.     (if (or (eqv? c #\newline) (eof-object? c))
  64.     (set! tok:column 0)
  65.     (set! tok:column (+ 1 tok:column)))
  66.     c))
  67. (define (tok:bump-column pos . ports)
  68.   ((lambda (thunk)
  69.      (cond ((null? ports) (thunk))
  70.        (else (fluid-let ((*prec:port* (car ports))) (thunk)))))
  71.    (lambda ()
  72.      (cond ((eqv? #\newline (tok:peek-char))
  73.         (tok:read-char)))        ;to do newline
  74.      (set! tok:column (+ tok:column pos)))))
  75. (define (prec:warn . msgs)
  76.   (do ((j (+ -1 tok:column) (+ -8 j)))
  77.       ((> 8 j)
  78.        (do ((i j (+ -1 i)))
  79.        ((>= 0 i))
  80.      (display #\ )))
  81.     (display slib:tab))
  82.   (display "^ ")
  83.   (newline)
  84.   (for-each (lambda (x) (write x) (display #\ )) msgs)
  85.   (newline))
  86.  
  87. ;; Structure of lexical records.
  88. (define tok:make-rec cons)
  89. (define tok:cc car)
  90. (define tok:sfp cdr)
  91.  
  92. (define (tok:lookup alist char)
  93.   (if (eof-object? char)
  94.       #f
  95.       (let ((pair (assv char alist)))
  96.     (and pair (cdr pair)))))
  97.  
  98. (define (tok:char-group group chars chars-proc)
  99.   (map (lambda (token)
  100. ;;;     (let ((oldlexrec (tok:lookup *syn-defs* token)))
  101. ;;;       (cond ((or (not oldlexrec) (eqv? (tok:cc oldlexrec) group)))
  102. ;;;         (else (math:warn 'cc-of token 'redefined-to- group))))
  103.      (cons token (tok:make-rec group chars-proc)))
  104.        (cond ((string? chars) (string->list chars))
  105.          ((char? chars) (list chars))
  106.          (else chars))))
  107.  
  108. (define (tokenize)
  109.   (let* ((char (tok:read-char))
  110.      (rec (tok:lookup *syn-rules* char))
  111.      (proc (and rec (tok:cc rec)))
  112.      (clist (list char)))
  113.     (cond
  114.      ((not proc) char)
  115.      ((procedure? proc)
  116.       (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl))))
  117.       ((proc (tok:peek-char))
  118.        ((or (tok:sfp rec) list->string) clist))))
  119.      ((eqv? 0 proc) (tokenize))
  120.      (else
  121.       (do ((cl clist (begin (set-cdr! cl (list (tok:read-char))) (cdr cl))))
  122.       ((not (let* ((prec (tok:lookup *syn-rules* (tok:peek-char)))
  123.                (cclass (and prec (tok:cc prec))))
  124.           (or (eqv? cclass proc)
  125.               (eqv? cclass (+ -1 proc)))))
  126.        ((tok:sfp rec) clist)))))))
  127.  
  128. ;;; PREC:NUD is the null denotation (function and arguments to call when no
  129. ;;;    unclaimed tokens).
  130. ;;; PREC:LED is the left denotation (function and arguments to call when
  131. ;;;    unclaimed token is on left).
  132. ;;; PREC:LBP is the left binding power of this LED.  It is the first
  133. ;;; argument position of PREC:LED
  134.  
  135. (define (prec:nudf alist self)
  136.   (let ((pair (assoc (cons 'nud self) alist)))
  137.     (and pair (cdr pair))))
  138. (define (prec:ledf alist self)
  139.   (let ((pair (assoc (cons 'led self) alist)))
  140.     (and pair (cdr pair))))
  141. (define (prec:lbp alist self)
  142.   (let ((pair (assoc (cons 'led self) alist)))
  143.     (and pair (cadr pair))))
  144.  
  145. (define (prec:call-or-list proc . args)
  146.   (prec:apply-or-cons proc args))
  147. (define (prec:apply-or-cons proc args)
  148.   (if (procedure? proc) (apply proc args) (cons (or proc '?) args)))
  149.  
  150. ;;; PREC:SYMBOLFY and PREC:DE-SYMBOLFY are not exact inverses.
  151. (define (prec:symbolfy obj)
  152.   (cond ((symbol? obj) obj)
  153.     ((string? obj) (string->symbol obj))
  154.     ((char? obj) (string->symbol (string obj)))
  155.     (else obj)))
  156.  
  157. (define (prec:de-symbolfy obj)
  158.   (cond ((symbol? obj) (symbol->string obj))
  159.     (else obj)))
  160.  
  161. ;;;Calls to set up tables.
  162.  
  163. (define (prec:define-grammar . synlsts)
  164.   (set! *syn-defs* (append (apply append synlsts) *syn-defs*)))
  165.  
  166. (define (prec:make-led toks . args)
  167.   (map (lambda (tok)
  168.      (cons (cons 'led (prec:de-symbolfy tok))
  169.            args))
  170.        (if (pair? toks) toks (list toks))))
  171. (define (prec:make-nud toks . args)
  172.   (map (lambda (tok)
  173.      (cons (cons 'nud (prec:de-symbolfy tok))
  174.            args))
  175.        (if (pair? toks) toks (list toks))))
  176.  
  177. ;;; Produce dynamically augmented grammars.
  178. (define (prec:process-binds binds rules)
  179.   (if (and #f (not (null? binds)) (eq? #t (car binds)))
  180.       (cdr binds)
  181.       (append binds rules)))
  182.  
  183. ;;(define (prec:replace-rules) some-sort-of-magic-cookie)
  184.  
  185. ;;; Here are the procedures to define high-level grammar, along with
  186. ;;; utility functions called during parsing.  The utility functions
  187. ;;; (prec:parse-*) could be incorportated into the defining commands,
  188. ;;; but tracing these functions is useful for debugging.
  189.  
  190. (define (prec:delim tk)
  191.   (prec:make-led tk 0 #f))
  192.  
  193. (define (prec:nofix tk sop . binds)
  194.   (prec:make-nud tk prec:parse-nofix sop (apply append binds)))
  195. (define (prec:parse-nofix self sop binds)
  196.   (set! *syn-rules* (prec:process-binds binds *syn-rules*))
  197.   (prec:call-or-list (or sop (prec:symbolfy self))))
  198.  
  199. (define (prec:prefix tk sop bp . binds)
  200.   (prec:make-nud tk prec:parse-prefix sop bp (apply append binds)))
  201. (define (prec:parse-prefix self sop bp binds)
  202.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  203.     (prec:call-or-list (or sop (prec:symbolfy self)) (prec:parse1 bp))))
  204.  
  205. (define (prec:infix tk sop lbp bp . binds)
  206.   (prec:make-led tk lbp prec:parse-infix sop bp (apply append binds)))
  207. (define (prec:parse-infix left self lbp sop bp binds)
  208.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  209.     (prec:call-or-list (or sop (prec:symbolfy self)) left (prec:parse1 bp))))
  210.  
  211. (define (prec:nary tk sop bp)
  212.   (prec:make-led tk bp prec:parse-nary sop bp))
  213. (define (prec:parse-nary left self lbp sop bp)
  214.   (prec:apply-or-cons (or sop (prec:symbolfy self))
  215.               (cons left (prec:parse-list self bp))))
  216.  
  217. (define (prec:postfix tk sop lbp . binds)
  218.   (prec:make-led tk lbp prec:parse-postfix sop (apply append binds)))
  219. (define (prec:parse-postfix left self lbp sop binds)
  220.   (set! *syn-rules* (prec:process-binds binds *syn-rules*))
  221.   (prec:call-or-list (or sop (prec:symbolfy self)) left))
  222.  
  223. (define (prec:prestfix tk sop bp . binds)
  224.   (prec:make-nud tk prec:parse-rest sop bp (apply append binds)))
  225. (define (prec:parse-rest self sop bp binds)
  226.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  227.     (prec:apply-or-cons (or sop (prec:symbolfy self)) (prec:parse-list #f bp))))
  228.  
  229. (define (prec:commentfix tk stp match . binds)
  230.   (append
  231.    (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds))
  232.    (prec:make-led tk 220 prec:parse-ledcomment stp match (apply append binds))))
  233. (define (prec:parse-nudcomment self stp match binds)
  234.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  235.     (tok:read-through-comment stp match)
  236.     (prec:advance)
  237.     (cond ((prec:delim? (force prec:token)) #f)
  238.       (else (prec:parse1 prec:bp)))))
  239. (define (prec:parse-ledcomment left lbp self stp match binds)
  240.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  241.     (tok:read-through-comment stp match)
  242.     (prec:advance)
  243.     left))
  244. (define (tok:read-through-comment stp match)
  245.   (set! match (if (char? match)
  246.           (string match)
  247.           (prec:de-symbolfy match)))
  248.   (cond ((procedure? stp)
  249.      (let* ((len #f)
  250.         (str (call-with-output-string
  251.               (lambda (sp)
  252.             (set! len (find-string-from-port?
  253.                    match *prec:port*
  254.                    (lambda (c) (display c sp) #f)))))))
  255.        (stp (and len (substring str 0 (- len (string-length match)))))))
  256.     (else (find-string-from-port? match *prec:port*))))
  257.  
  258. (define (prec:matchfix tk sop sep match . binds)
  259.   (define sep-lbp 0)
  260.   (prec:make-nud tk prec:parse-matchfix
  261.          sop sep-lbp sep match
  262.          (apply append (prec:delim match) binds)))
  263. (define (prec:parse-matchfix self sop sep-lbp sep match binds)
  264.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  265.     (cond (sop (prec:apply-or-cons
  266.         sop (prec:parse-delimited sep sep-lbp match)))
  267.       ((equal? (force prec:token) match)
  268.        (prec:warn 'expression-missing)
  269.        (prec:advance)
  270.        '?)
  271.       (else (let ((ans (prec:parse1 0))) ;just parenthesized expression
  272.           (cond ((equal? (force prec:token) match)
  273.              (prec:advance))
  274.             ((prec:delim? (force prec:token))
  275.              (prec:warn 'mismatched-delimiter (force prec:token)
  276.                     'not match)
  277.              (prec:advance))
  278.             (else (prec:warn 'delimiter-expected--ignoring-rest
  279.                      (force prec:token) 'expected match
  280.                      'or-delimiter)
  281.                   (do () ((prec:delim? (force prec:token)))
  282.                 (prec:parse1 0))))
  283.           ans)))))
  284.  
  285. (define (prec:inmatchfix tk sop sep match lbp . binds)
  286.   (define sep-lbp 0)
  287.   (prec:make-led tk lbp prec:parse-inmatchfix
  288.          sop sep-lbp sep match
  289.          (apply append (prec:delim match) binds)))
  290. (define (prec:parse-inmatchfix left self lbp sop sep-lbp sep match binds)
  291.   (fluid-let ((*syn-rules* (prec:process-binds binds *syn-rules*)))
  292.     (prec:apply-or-cons
  293.      sop (cons left (prec:parse-delimited sep sep-lbp match)))))
  294.  
  295. ;;;; Here is the code which actually parses.
  296.  
  297. (define prec:bp #f)            ;dynamically bound
  298. (define prec:token #f)
  299. (define (prec:advance)
  300.   (set! prec:token (delay (tokenize))))
  301. (define (prec:advance-return-last)
  302.   (let ((last (and prec:token (force prec:token))))
  303.     (prec:advance)
  304.     last))
  305.  
  306. (define (prec:nudcall self)
  307.   (let ((pob (prec:nudf *syn-rules* self)))
  308.     (cond
  309.      (pob (let ((proc (car pob)))
  310.         (cond ((procedure? proc) (apply proc self (cdr pob)))
  311.           (proc (cons proc (cdr pob)))
  312.           (else '?))))
  313.      ((char? self) (prec:warn 'extra-separator)
  314.            (prec:advance)
  315.            (prec:nudcall (force prec:token)))
  316.      ((string? self) (string->symbol self))
  317.      (else self))))
  318.  
  319. (define (prec:ledcall left self)
  320.   (let* ((pob (prec:ledf *syn-rules* self)))
  321.     (apply (cadr pob) left self (cdr pob))))
  322.  
  323. ;;; PREC:PARSE1 is the heart.
  324. (define (prec:parse1 bp)
  325.   (fluid-let ((prec:bp bp))
  326.     (do ((left (prec:nudcall (prec:advance-return-last))
  327.            (prec:ledcall left (prec:advance-return-last))))
  328.     ((or (>= bp 200)        ;to avoid unneccesary lookahead
  329.          (>= bp (or (prec:lbp *syn-rules* (force prec:token)) 0))
  330.          (not left))
  331.      left))))
  332.  
  333. (define (prec:delim? token)
  334.   (or (eof-object? token) (<= (or (prec:lbp *syn-rules* token) 220) 0)))
  335.  
  336. (define (prec:parse-list sep bp)
  337.   (cond ((prec:delim? (force prec:token))
  338.      (prec:warn 'expression-missing)
  339.      '(?))
  340.     (else
  341.      (let ((f (prec:parse1 bp)))
  342.        (cons f (cond ((equal? (force prec:token) sep)
  343.               (prec:advance)
  344.               (cond ((equal? (force prec:token) sep)
  345.                  (prec:warn 'expression-missing)
  346.                  (prec:advance)
  347.                  (cons '? (prec:parse-list sep bp)))
  348.                 ((prec:delim? (force prec:token))
  349.                  (prec:warn 'expression-missing)
  350.                  '(?))
  351.                 (else (prec:parse-list sep bp))))
  352.              ((prec:delim? (force prec:token)) '())
  353.              ((not sep) (prec:parse-list sep bp))
  354.              ((prec:delim? sep) (prec:warn 'separator-missing)
  355.                         (prec:parse-list sep bp))
  356.              (else '())))))))
  357.  
  358. (define (prec:parse-delimited sep bp delim)
  359.   (cond ((equal? (force prec:token) sep)
  360.      (prec:warn 'expression-missing)
  361.      (prec:advance)
  362.      (cons '? (prec:parse-delimited sep delim)))
  363.     ((prec:delim? (force prec:token))
  364.      (if (not (equal? (force prec:token) delim))
  365.          (prec:warn 'mismatched-delimiter (force prec:token)
  366.             'expected delim))
  367.      (if (not sep) (prec:warn 'expression-missing))
  368.      (prec:advance)
  369.      (if sep '() '(?)))
  370.     (else (let ((ans (prec:parse-list sep bp)))
  371.         (cond ((equal? (force prec:token) delim))
  372.               ((prec:delim? (force prec:token))
  373.                (prec:warn 'mismatched-delimiter (force prec:token)
  374.                   'expecting delim))
  375.               (else (prec:warn 'delimiter-expected--ignoring-rest
  376.                        (force prec:token) '...)
  377.                 (do () ((prec:delim? (force prec:token)))
  378.                   (prec:parse1 bp))))
  379.         (prec:advance)
  380.         ans))))
  381.  
  382. (define (prec:parse grammar delim . port)
  383.   (set! delim (prec:de-symbolfy delim))
  384.   (fluid-let ((*syn-rules* (append (prec:delim delim) grammar))
  385.           (*prec:port* (if (null? port) (current-input-port) (car port))))
  386.     (prec:advance)            ; setup prec:token with first token
  387.     (cond ((eof-object? (force prec:token)) (force prec:token))
  388.       ((equal? (force prec:token) delim) #f)
  389.       (else
  390.        (let ((ans (prec:parse1 0)))
  391.          (cond ((eof-object? (force prec:token)))
  392.            ((equal? (force prec:token) delim))
  393.            (else (prec:warn 'delimiter-expected--ignoring-rest
  394.                     (force prec:token) 'not delim)
  395.              (do () ((or (equal? (force prec:token) delim)
  396.                      (eof-object? (force prec:token))))
  397.                (prec:advance))))
  398.          ans)))))
  399.  
  400. (define tok:decimal-digits "0123456789")
  401. (define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  402. (define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
  403. (define tok:whitespaces
  404.   (do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i))
  405.        (ws "" (if (char-whitespace? (integer->char i))
  406.           (string-append ws (string (integer->char i)))
  407.           ws)))
  408.       ((negative? i) ws)))
  409.  
  410. ;;;;The parse tables.
  411. ;;; Definitions accumulate in top-level variable *SYN-DEFS*.
  412. (set! *syn-defs* '())            ;Make sure *SYN-DEFS* is empty.
  413.  
  414. ;;; Ignore Whitespace characters.
  415. (prec:define-grammar (tok:char-group 0 tok:whitespaces #f))
  416.  
  417. ;;; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to
  418. ;;; avoid problems at end of files.
  419. (case (software-type)
  420.   ((MSDOS)
  421.    (if (not (char-whitespace? (integer->char 26)))
  422.        (prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
  423.        )))
  424.  
  425. ;;; Save these convenient definitions.
  426. (define *syn-ignore-whitespace* *syn-defs*)
  427. (set! *syn-defs* '())
  428.  
  429. (define (prec:trace)
  430.   (require 'trace)
  431.   (trace prec:parse prec:parse1
  432.      prec:parse-delimited prec:parse-list
  433.      prec:call-or-list prec:apply-or-cons
  434.      ;;tokenize prec:advance-return-last prec:advance
  435.      prec:nudcall prec:ledcall
  436.      prec:parse-nudcomment prec:parse-ledcomment
  437.      prec:parse-delimited prec:parse-list
  438.      prec:parse-nary prec:parse-rest
  439.      prec:parse-matchfix prec:parse-inmatchfix
  440.      prec:parse-prefix prec:parse-infix prec:parse-postfix
  441.      ;;prec:delim?
  442.      ;;prec:ledf prec:nudf prec:lbp
  443.      )
  444.   (set! *qp-width* 333))
  445.  
  446. ;;(begin (trace-all "prec.scm") (set! *qp-width* 333))
  447. ;;(pretty-print (grammar-read-tab (get-grammar 'standard)))
  448. ;;(prec:trace)
  449.